home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / syscalls.scm < prev    next >
Text File  |  1995-10-28  |  32KB  |  1,085 lines
  1. ;;; POSIX system-call Scheme binding.
  2. ;;; Copyright (c) 1993 by Olin Shivers.
  3.  
  4. ;;; Scheme48 implementation.
  5.  
  6. ;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
  7.  
  8. (foreign-source
  9.   "#include <sys/signal.h>"
  10.   "#include <sys/types.h>"
  11.   "#include <sys/times.h>"
  12.   "#include <sys/time.h>"
  13.   "#include <fcntl.h>        /* for O_RDWR */" ; ???
  14.   "#include <sys/stat.h>"
  15.   "#include <netdb.h>"
  16.   "#include <pwd.h>"
  17.   "#include <unistd.h>"
  18.   ""
  19.   "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  20.   "#include \"dirstuff1.h\""
  21.   "#include \"fdports1.h\""
  22.   "#include \"select1.h\""
  23.   "#include \"syscalls1.h\""
  24.   "#include \"userinfo1.h\""
  25.   ""
  26.   "extern int errno;"
  27.   ""
  28.   "#define errno_on_zero_or_false(x) ((x) ? SCHFALSE : ENTER_FIXNUM(errno))"
  29.   "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  30.   "#define False_on_zero(x) ((x) ? ENTER_FIXNUM(x) : SCHFALSE)" ; Not a function.
  31.   "" "")
  32.  
  33. ;;; Macros for converting syscalls that return error codes to ones that
  34. ;;; raise exceptions on errors.
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36.  
  37. ;;; DEFINE-ERRNO-SYSCALL defines an error-signalling syscall procedure from 
  38. ;;; one that returns an error code as its first return value -- #f for win,
  39. ;;; errno for lose.
  40. ;;;
  41. ;;; (define-errno-syscall (SYSCALL ARGS) SYSCALL/ERRNO . RET-VALS) ==>
  42. ;;;
  43. ;;; (define (SYSCALL . ARGS)
  44. ;;;   (receive (err . RET-VALS) (SYSCALL/ERRNO . ARGS)
  45. ;;;     (if err (errno-error err SYSCALL . ARGS)
  46. ;;;         (values . RET-VALS))))
  47.     
  48. (define-syntax define-errno-syscall
  49.   (syntax-rules ()
  50.     ((define-errno-syscall (syscall arg ...) syscall/errno
  51.        ret-val ...)
  52.      (define (syscall arg ...)
  53.        (receive (err ret-val ...) (syscall/errno arg ...)
  54.          (if err (errno-error err syscall arg ...)
  55.              (values ret-val ...)))))
  56.  
  57.     ;;; This case handles rest args
  58.     ((define-errno-syscall (syscall . args) syscall/errno
  59.        ret-val ...)
  60.      (define (syscall . args)
  61.        (receive (err ret-val ...) (apply syscall/errno . args)
  62.          (if err (apply errno-error err syscall args)
  63.              (values ret-val ...)))))))
  64.  
  65. ;;; DEFINE-SIMPLE-ERRNO-SYSCALL is for the simple case of a system call
  66. ;;; that returns no interesting value other than its errno code (or #f
  67. ;;; for success). This is most syscalls.
  68. ;;;
  69. ;;; (define-simple-errno-syscall (SYSCALL . ARGS) SYSCALL/ERRNO) =>
  70. ;;;
  71. ;;; (define (SYSCALL . ARGS)
  72. ;;;   (cond ((SYSCALL/ERRNO . ARGS) => 
  73. ;;;          (lambda (err) (errno-error err SYSCALL . ARGS)))))
  74.  
  75. (define-syntax define-simple-errno-syscall
  76.   (syntax-rules ()
  77.     ((define-simple-errno-syscall (syscall arg ...) syscall/errno)
  78.      (define (syscall arg ...)
  79.        (cond ((syscall/errno arg ...) => 
  80.               (lambda (err) (errno-error err syscall arg ...))))))
  81.  
  82.  
  83.     ;; This case handles a single rest arg.
  84.     ((define-simple-errno-syscall (syscall . rest) syscall/errno)
  85.      (define (syscall . rest)
  86.        (cond ((apply syscall/errno rest) => 
  87.               (lambda (err) (apply errno-error err syscall rest))))))))
  88.  
  89.  
  90. ;;; Process
  91. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92.  
  93. (define-foreign %%exec/errno
  94.   (scheme_exec (string prog)
  95.            (vector-desc argv)
  96.            (desc env)) ; string vector or #t.
  97.   integer)
  98.  
  99. (define (%%exec prog argv env)
  100.   (errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute.
  101.  
  102. (define (%exec prog arg-list env)
  103.   (let ((argv (mapv! stringify (list->vector arg-list)))
  104.     (prog (stringify prog))
  105.     (env (if (eq? env #t) #t
  106.          (list->vector (alist->env-list env)))))
  107.     (cloexec-unrevealed-ports)
  108.     (%%exec prog argv env)))
  109.  
  110.  
  111. (define-foreign exit/errno ; errno -- misnomer.
  112.   (exit (integer status))
  113.   ignore)
  114.  
  115. (define-foreign %exit/errno ; errno -- misnomer
  116.   (_exit (integer status))
  117.   ignore)
  118.  
  119. (define (%exit . maybe-status)
  120.   (%exit/errno (optional-arg maybe-status 0))
  121.   (error "Yikes! %exit returned."))
  122.  
  123.  
  124. (define-foreign %%fork/errno (fork)
  125.   (multi-rep (to-scheme pid_t errno_or_false)
  126.              pid_t))
  127.  
  128. (define-errno-syscall (%%fork) %%fork/errno
  129.   pid)
  130.  
  131.  
  132. ;;; Posix waitpid(2) call.
  133. (define-foreign %wait-pid/errno (wait_pid (integer pid) (integer options))
  134.   desc        ; errno or #f
  135.   integer  ; process' id
  136.   integer) ; process' status
  137.  
  138.  
  139. ;;; Miscellaneous process state
  140. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  141.  
  142. ;;; Working directory
  143.  
  144. (define-foreign %chdir/errno
  145.   (chdir (string directory))
  146.   (to-scheme integer errno_or_false))
  147.  
  148. (define-simple-errno-syscall (%chdir dir) %chdir/errno)
  149.  
  150. (define (chdir . maybe-dir)
  151.   (let ((dir (optional-arg maybe-dir ".")))
  152.     (%chdir (ensure-file-name-is-nondirectory dir))))
  153.  
  154.  
  155. (define-foreign cwd/errno (scheme_cwd)
  156.   (to-scheme integer "False_on_zero") ; errno or #f
  157.   string) ; directory (or #f on error)
  158.  
  159. (define-errno-syscall (cwd) cwd/errno
  160.   dir)
  161.  
  162.  
  163. ;;; GID
  164.  
  165. (define-foreign user-gid  (getgid) gid_t)
  166. (define-foreign user-effective-gid (getegid) gid_t)
  167.  
  168. (define-foreign set-gid/errno (setgid (gid_t id))
  169.   (to-scheme integer errno_or_false))
  170.  
  171. (define-simple-errno-syscall (set-gid gid) set-gid/errno)
  172.  
  173. (define-foreign %num-supplementary-gids/errno (num_supp_groups)
  174.   (multi-rep (to-scheme integer errno_or_false)
  175.          integer))
  176.  
  177. (define-foreign load-groups/errno (get_groups (vector-desc group-vec))
  178.   (multi-rep (to-scheme integer errno_or_false)
  179.          integer))
  180.  
  181. (define (user-supplementary-gids)
  182.   (receive (err numgroups) (%num-supplementary-gids/errno)
  183.     (if err (errno-error err user-supplementary-gids)
  184.     (let ((vec (make-vector numgroups)))
  185.       (receive (err numgroups2) (load-groups/errno vec)
  186.         (if err (errno-error err user-supplementary-gids)
  187.         (vector->list vec)))))))
  188.  
  189.  
  190. ;;; UID
  191.  
  192. (define-foreign user-uid        (getuid)  uid_t)
  193. (define-foreign user-effective-uid     (geteuid) uid_t)
  194.  
  195. (define-foreign set-uid/errno (setuid (uid_t id))
  196.   (to-scheme integer errno_or_false))
  197.  
  198. (define-simple-errno-syscall (set-uid uid_t) set-uid/errno)
  199.  
  200. (define-foreign %user-login-name (my_username)
  201.   static-string)
  202.   
  203. (define (user-login-name)
  204.   (or (%user-login-name)
  205.       (error "Cannot get your name")))
  206.  
  207. ;;; PID
  208.  
  209. (define-foreign pid (getpid) pid_t)
  210. (define-foreign parent-pid (getppid) pid_t)
  211.  
  212.  
  213. ;;; Process groups and session ids
  214. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  215.  
  216. (define-foreign process-group (getpgrp) pid_t)
  217. (define-foreign %set-process-group/errno
  218.   (setpgid (pid_t pid) (pid_t groupid))
  219.   (to-scheme integer errno_or_false))
  220.  
  221. (define-simple-errno-syscall (%set-process-group pid pgrp)
  222.   %set-process-group/errno)
  223.  
  224.  
  225. (define (set-process-group arg1 . maybe-arg2)
  226.   (receive (pid pgrp) (if (null? maybe-arg2)
  227.               (values (pid) arg1)
  228.               (values arg1 (car maybe-arg2)))
  229.        (%set-process-group pid pgrp)))
  230.  
  231.  
  232. (define-foreign become-session-leader/errno (setsid)
  233.   (multi-rep (to-scheme pid_t errno_or_false)
  234.          pid_t))
  235.  
  236. (define-errno-syscall (become-session-leader) become-session-leader/errno
  237.   sid)
  238.  
  239.  
  240. ;;; UMASK
  241.  
  242. (define-foreign set-umask (umask (mode_t mask)) no-declare ; integer on SunOS
  243.   mode_t)
  244.  
  245. (define (umask)
  246.   (let ((m (set-umask 0)))
  247.     (set-umask m)
  248.     m))
  249.  
  250.  
  251. ;;; PROCESS TIMES
  252.  
  253. ;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
  254. ;;; OOPS: The ret values should be clock_t, not int, but cig can't handle it.
  255.  
  256. (define-foreign process-times/errno (process_times)
  257.   (to-scheme integer errno_or_false)
  258.   integer    ; user   cpu time
  259.   integer    ; system cpu time
  260.   integer    ; user   cpu time for me and all my descendants.
  261.   integer)    ; system cpu time for me and all my descendants.
  262.  
  263. (define-errno-syscall (process-times) process-times/errno
  264.   utime stime cutime cstime)
  265.  
  266. (define-foreign cpu-ticks/sec (cpu_clock_ticks_per_sec) integer)
  267.  
  268. ;;; File system
  269. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  270.  
  271. ;;; Useful little utility for generic ops that work on filenames, fd's or
  272. ;;; ports.
  273.  
  274. (define (generic-file-op thing fd-op fname-op)
  275.   (if (string? thing) (fname-op thing)
  276.       (call/fdes thing fd-op)))
  277.  
  278.  
  279. (define-foreign set-file-mode/errno
  280.   (chmod (string path) (mode_t mode)) no-declare ; integer on SunOS
  281.   (to-scheme integer errno_or_false))
  282.  
  283. ; IBM's AIX include files declare fchmod(char*, mode_t).
  284. ; Amazing, but true. So we must prevent this def-foreign from issuing
  285. ; the conflicting, correct declaration. Hence the NO-DECLARE.
  286.  
  287. (define-foreign set-fdes-mode/errno
  288.   (fchmod (integer fd) (mode_t mode)) ; integer on SunOS
  289.   no-declare ; Workaround for AIX bug.
  290.   (to-scheme integer errno_or_false))
  291.  
  292. (define-simple-errno-syscall (set-file-mode thing mode)
  293.   (lambda (thing mode)
  294.     (generic-file-op thing
  295.              (lambda (fd)    (set-fdes-mode/errno fd    mode))
  296.              (lambda (fname) (set-file-mode/errno fname mode)))))
  297.  
  298.  
  299. ;;; NO-DECLARE: gcc unistd.h bogusness.
  300. (define-foreign set-file-uid&gid/errno
  301.   (chown (string path) (uid_t uid) (gid_t gid)) no-declare
  302.   (to-scheme integer errno_or_false))
  303.  
  304. (define-foreign set-fdes-uid&gid/errno
  305.   (fchown (integer fd) (uid_t uid) (gid_t gid))
  306.   (to-scheme integer errno_or_false))
  307.  
  308. (define-simple-errno-syscall (set-file-owner thing uid)
  309.   (lambda (thing uid)
  310.     (generic-file-op thing
  311.              (lambda (fd)    (set-fdes-uid&gid/errno fd    uid -1))
  312.              (lambda (fname) (set-file-uid&gid/errno fname uid -1)))))
  313.  
  314. (define-simple-errno-syscall (set-file-group thing gid)
  315.   (lambda (thing gid)
  316.     (generic-file-op thing
  317.              (lambda (fd)    (set-fdes-uid&gid/errno fd    gid -1))
  318.              (lambda (fname) (set-file-uid&gid/errno fname gid -1)))))
  319.  
  320.  
  321. ;;; Uses real uid and gid, not effective. I don't use this anywhere.
  322.  
  323. (define-foreign %file-ruid-access-not?
  324.   (access (string path)
  325.       (integer perms))
  326.   bool)
  327.  
  328. ;(define (file-access? path perms)
  329. ;  (not (%file-access-not? path perms)))
  330. ;
  331. ;(define (file-executable? fname)
  332. ;  (file-access? fname 1))
  333. ;
  334. ;(define (file-writable? fname)
  335. ;  (file-access? fname 2))
  336. ;
  337. ;(define (file-readable? fname)
  338. ;  (file-access? fname 4))
  339.  
  340.  
  341. (define-foreign create-hard-link/errno
  342.   (link (string original-name) (string new-name))
  343.   (to-scheme integer errno_or_false))
  344.  
  345. (define-simple-errno-syscall (create-hard-link original-name new-name)
  346.   create-hard-link/errno)
  347.  
  348.  
  349. (define-foreign create-fifo/errno (mkfifo (string path) (mode_t mode))
  350.   no-declare ; integer on SunOS
  351.   (to-scheme integer errno_or_false))
  352.  
  353. (define-simple-errno-syscall (create-fifo path mode) create-fifo/errno)
  354.  
  355.  
  356. (define-foreign create-directory/errno
  357.   (mkdir (string path) (mode_t mode)) no-declare ; integer on SunOS.
  358.   (to-scheme integer errno_or_false))
  359.  
  360. (define (create-directory path . maybe-mode)
  361.   (let ((mode (optional-arg maybe-mode #o777))
  362.     (fname (ensure-file-name-is-nondirectory path)))
  363.     (cond ((create-directory/errno fname mode) =>
  364.            (lambda (err)
  365.          (if err (errno-error err create-directory path mode)))))))
  366.  
  367.  
  368. (define-foreign read-symlink/errno (scm_readlink (string path))
  369.   (multi-rep (to-scheme string errno_on_zero_or_false) ; NULL => errno, otw #f
  370.          static-string))
  371.              
  372. (define-errno-syscall (read-symlink path) read-symlink/errno
  373.   new-path)
  374.  
  375.  
  376. (define-foreign %rename-file/errno
  377.   (rename (string old-name) (string new-name))
  378.   (to-scheme integer errno_or_false))
  379.   
  380. (define-simple-errno-syscall (%rename-file old-name new-name)
  381.   %rename-file/errno)
  382.  
  383.  
  384. (define-foreign delete-directory/errno
  385.   (rmdir (string path))
  386.   (to-scheme integer errno_or_false))
  387.  
  388. (define-simple-errno-syscall (delete-directory path) delete-directory/errno)
  389.  
  390.  
  391. (define-foreign %utime/errno (scm_utime (string path)
  392.                     (integer ac_hi) (integer ac_lo)
  393.                     (integer m_hi)  (integer m_lo))
  394.   (to-scheme integer errno_or_false))
  395.  
  396. (define-foreign %utime-now/errno (scm_utime_now (string path))
  397.   (to-scheme integer errno_or_false))
  398.                     
  399.  
  400. ;;; (SET-FILE-TIMES/ERRNO path [access-time mod-time])
  401.  
  402. (define (set-file-times/errno path . maybe-times)
  403.   (if (pair? maybe-times)
  404.       (let* ((access-time (real->exact-integer (car maybe-times)))
  405.          (mod-time (if (pair? (cddr maybe-times))
  406.                (error "Too many arguments to set-file-times/errno"
  407.                   (cons path maybe-times))
  408.                (real->exact-integer (cadr maybe-times)))))
  409.     (%utime/errno path (hi8 access-time) (lo24 access-time)
  410.                    (hi8 mod-time)    (lo24 mod-time)))
  411.       (%utime-now/errno path)))
  412.  
  413. (define-simple-errno-syscall (set-file-times . args) set-file-times/errno)
  414.  
  415.  
  416. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  417. ;;; STAT
  418.  
  419. (define-foreign stat-file/errno
  420.   (scheme_stat (string path) (vector-desc data) (bool chase?))
  421.   (to-scheme integer "False_on_zero")) ; errno or #f
  422.  
  423. ;(define-errno-syscall (stat-file fd data chase?) stat-file/errno)
  424.  
  425. (define-foreign stat-fdes/errno
  426.   (scheme_fstat (integer fd) (vector-desc data))
  427.   (to-scheme integer "False_on_zero")) ; errno or #f
  428.  
  429. ;(define-errno-syscall (stat-fdes fd data) stat-fdes/errno)
  430.  
  431. (define-record file-info
  432.   type
  433.   device
  434.   inode
  435.   mode
  436.   nlinks
  437.   uid
  438.   gid
  439.   size
  440.   atime
  441.   mtime
  442.   ctime
  443.   )
  444.  
  445.  
  446. ;;; Should be redone to return multiple-values.
  447. (define (file-info/errno fd/port/fname chase?)
  448.   (let ((ans-vec (make-vector 14))
  449.     (time-hack (lambda (lo-24 hi-8)
  450.              (let ((val (+ (arithmetic-shift hi-8 24) lo-24)))
  451.                (if (zero? (bitwise-and hi-8 #x80)) val
  452.                ;; Oops -- it's a negative 32-bit value.
  453.                ;; Or in all the sign bits.
  454.                (bitwise-ior (bitwise-not #xffffffff)
  455.                     val)))))
  456.     (file-type (lambda (type-code)
  457.              (vector-ref '#(block-special char-special directory fifo
  458.                           regular socket symlink)
  459.                  type-code))))
  460.  
  461.     (cond ((generic-file-op fd/port/fname
  462.                 (lambda (fd)
  463.                   (stat-fdes/errno fd ans-vec))
  464.                 (lambda (fname)
  465.                   (stat-file/errno fname ans-vec chase?)))
  466.        => (lambda (err) (values err #f)))
  467.  
  468.       (else (values #f (make-file-info (file-type (vector-ref ans-vec 0))
  469.                        (vector-ref ans-vec 1)
  470.                        (vector-ref ans-vec 2)
  471.                        (vector-ref ans-vec 3)
  472.                        (vector-ref ans-vec 4)
  473.                        (vector-ref ans-vec 5)
  474.                        (vector-ref ans-vec 6)
  475.                        (vector-ref ans-vec 7)
  476.                        (time-hack (vector-ref ans-vec 8)
  477.                               (vector-ref ans-vec 9))
  478.                        (time-hack (vector-ref ans-vec 10)
  479.                               (vector-ref ans-vec 11))
  480.                        (time-hack (vector-ref ans-vec 12)
  481.                               (vector-ref ans-vec 13))))))))
  482.         
  483. (define (file-info fd/port/fname . maybe-chase?)
  484.   (let ((chase? (optional-arg maybe-chase? #t)))
  485.     (receive (err info) (file-info/errno fd/port/fname chase?)
  486.       (if err (errno-error err file-info fd/port/fname chase?)
  487.       info))))
  488.  
  489.  
  490. (define file-attributes
  491.   (deprecated-proc file-info "file-attributes" "Use file-info instead."))
  492.  
  493.  
  494. ;;; "no-declare" as there is no agreement among the OS's as to whether or not
  495. ;;; the OLD-NAME arg is "const". It *should* be const.
  496.  
  497. (define-foreign create-symlink/errno
  498.   (symlink (string old-name) (string new-name))    no-declare
  499.   (to-scheme integer errno_or_false))
  500.   
  501. ;(define-simple-errno-syscall (create-symlink old-name new-name)
  502. ;  create-symlink/errno)
  503.  
  504.  
  505. ;;; "no-declare" as there is no agreement among the OS's as to whether or not
  506. ;;; the PATH arg is "const". It *should* be const.
  507.  
  508. (define-foreign truncate-file/errno
  509.   (truncate (string path) (off_t length))     no-declare
  510.   (to-scheme integer errno_or_false))
  511.  
  512. (define-foreign truncate-fdes/errno
  513.   (ftruncate (integer fd) (off_t length))   no-declare ; Indigo bogosity.
  514.   (to-scheme integer errno_or_false))
  515.  
  516. (define-simple-errno-syscall (truncate-file path length)
  517.   (lambda (thing length)
  518.     (generic-file-op thing
  519.              (lambda (fd)    (truncate-fdes/errno fd    length))
  520.              (lambda (fname) (truncate-file/errno fname length)))))
  521.  
  522.  
  523. (define-foreign delete-file/errno
  524.   (unlink (string path))
  525.   (to-scheme integer errno_or_false))
  526.  
  527. (define-simple-errno-syscall (delete-file path) delete-file/errno)
  528.  
  529.  
  530. (define-foreign sync-file/errno (fsync (integer fd))
  531.   (to-scheme integer errno_or_false))
  532.  
  533. (define-simple-errno-syscall (sync-file fd/port)
  534.   (lambda (fd/port)
  535.     (if (output-port? fd/port) (force-output fd/port))
  536.     (call/fdes fd/port sync-file/errno)))
  537.  
  538.  
  539. ;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
  540. (define-foreign sync-file-system (sync) no-declare ; Linux sux - says int
  541.   ignore)
  542.  
  543.  
  544. ;;; I/O
  545. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  546.  
  547. (define-foreign %close-fdes/errno (close (integer fd))
  548.   (to-scheme integer "errno_or_false"))
  549.  
  550. (define (%close-fdes fd)
  551.   (let lp ()
  552.     (let ((errno (%close-fdes/errno fd)))
  553.       (cond ((not errno)       #t)    ; Successful close.
  554.         ((= errno errno/badf) #f)    ; File descriptor already closed.
  555.         ((= errno errno/intr) (lp))    ; Retry.
  556.         (else
  557.          (errno-error errno %close-fdes fd))))))    ; You lose.
  558.  
  559. (define-foreign %dup/errno
  560.   (dup (integer fd))
  561.   (multi-rep (to-scheme integer errno_or_false)
  562.          integer))
  563.  
  564. (define-errno-syscall (%dup fd) %dup/errno
  565.    new-fd)
  566.  
  567. (define-foreign %dup2/errno
  568.   (dup2 (integer fd-from) (integer fd-to))
  569.   (multi-rep (to-scheme integer errno_or_false)
  570.          integer))
  571.  
  572. (define-errno-syscall (%dup2 fd-from fd-to) %dup2/errno 
  573.    new-fd)
  574.  
  575.  
  576. (define-foreign %fd-seek/errno
  577.   (lseek (integer fd) (off_t offset) (integer whence))
  578.   (multi-rep (to-scheme off_t errno_or_false)
  579.          off_t))
  580.  
  581.  
  582.  
  583. (define seek/set 0)            ;Unix codes for "whence"
  584. (define seek/delta 1)
  585. (define seek/end 2)
  586.  
  587. (define (seek fd/port offset . maybe-whence)
  588.   (let ((whence (optional-arg maybe-whence seek/set)))
  589.     (receive (err cursor)  
  590.     ((if (integer? fd/port) %fd-seek/errno %fdport-seek/errno)
  591.      fd/port
  592.      offset
  593.      whence)
  594.       (if err (errno-error err seek fd/port offset whence) cursor))))
  595.  
  596. (define (tell fd/port)
  597.   (receive (err offset) (if (integer? fd/port)
  598.                 (%fd-seek/errno fd/port 0 seek/delta) ; seek(fd)
  599.                 (%fdport-tell/errno fd/port))      ; ftell(f)
  600.     (if err (errno-error err tell fd/port) offset)))
  601.  
  602.  
  603. (define-foreign %char-ready-fdes?/errno
  604.   (char_ready_fdes (integer fd))
  605.   desc) ; errno, #t, or #f
  606.  
  607. (define (%char-ready-fdes? fd)
  608.   (let ((retval (%char-ready-fdes?/errno fd)))
  609.     (if (integer? retval) (errno-error retval %char-ready-fdes? fd)
  610.     retval)))
  611.  
  612.  
  613. (define-foreign %open/errno
  614.   (open (string path)
  615.     (integer flags)
  616.     (mode_t mode))    ; integer on SunOS
  617.   no-declare ; NOTE
  618.   (multi-rep (to-scheme integer errno_or_false)
  619.              integer))
  620.  
  621. (define-errno-syscall (%open path flags mode) %open/errno
  622.    fd)
  623.  
  624. (define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
  625.   (%open path flags (optional-arg maybe-mode #o666)))
  626.  
  627.  
  628. (define-foreign pipe-fdes/errno (scheme_pipe)
  629.   (to-scheme integer "False_on_zero")    ; Win: #f, lose: errno
  630.   integer    ; r
  631.   integer)    ; w
  632.  
  633. (define-errno-syscall (pipe-fdes) pipe-fdes/errno
  634.   r w)
  635.  
  636. (define (pipe)
  637.   (receive (r-fd w-fd) (pipe-fdes)
  638.     (let ((r (fdes->inport  r-fd))
  639.       (w (fdes->outport w-fd)))
  640.       (release-port-handle r)
  641.       (release-port-handle w)
  642.       (values r w))))
  643.  
  644. (define-foreign %read-fdes-char
  645.   (read_fdes_char (integer fd))
  646.   desc) ; Char or errno or #f (eof).
  647.  
  648. (define (read-fdes-char fd)
  649.   (let ((c (%read-fdes-char fd)))
  650.     (if (integer? c) (errno-error c read-fdes-char fd) c)))
  651.  
  652.  
  653. (define-foreign write-fdes-char/errno (write_fdes_char (char char) (integer fd))
  654.   (to-scheme integer errno_or_false))
  655.  
  656. (define-simple-errno-syscall (write-fdes-char char fd) write-fdes-char/errno)
  657.  
  658.  
  659. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  660. ;;; Read and write
  661.  
  662. (define-foreign read-fdes-substring!/errno
  663.   (read_fdes_substring (string-desc buf)
  664.                (integer start)
  665.                (integer end)
  666.                (integer fd))
  667.   (multi-rep (to-scheme integer errno_or_false)
  668.          integer))
  669.  
  670. (define-foreign write-fdes-substring/errno
  671.   (write_fdes_substring (string-desc buf)
  672.             (integer start)
  673.             (integer end)
  674.             (integer fd))
  675.   (multi-rep (to-scheme integer errno_or_false)
  676.          integer))
  677.  
  678.  
  679. ;;; Signals (rather incomplete)
  680. ;;; ---------------------------
  681.  
  682. (define-foreign signal-pid/errno
  683.   (kill (pid_t pid) (integer signal))
  684.   (to-scheme integer errno_or_false))
  685.  
  686. (define-simple-errno-syscall (signal-pid pid signal) signal-pid/errno)
  687.  
  688. (define (signal-process proc signal)
  689.   (signal-pid (cond ((proc? proc)    (proc:pid proc))
  690.             ((integer? proc) proc)
  691.             (else (error "Illegal proc passed to signal-process" proc)))
  692.           signal))
  693.  
  694. (define (signal-process-group proc-group signal)
  695.   (signal-pid (- (cond ((proc? proc-group)    (proc:pid proc-group))
  696.                ((integer? proc-group) proc-group)
  697.                (else (error "Illegal proc passed to signal-process-group"
  698.                                     proc-group))))
  699.               signal))
  700.  
  701. ;;; SunOS, not POSIX:
  702. ;;; (define-foreign signal-process-group/errno
  703. ;;;   (killpg (integer proc-group) (integer signal))
  704. ;;;   (to-scheme integer errno_or_false))
  705. ;;; 
  706. ;;; (define-simple-errno-syscall (signal-process-group proc-group signal)
  707. ;;;   signal-process-group/errno)
  708.  
  709. (define-foreign pause-until-interrupt (pause) no-declare ignore)
  710.  
  711. (define-foreign itimer (alarm (uint_t secs)) uint_t)
  712.  
  713. ;;; User info
  714. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  715.  
  716. (define-record user-info
  717.   name uid gid home-dir shell
  718.  
  719.   ;; Make user-info records print like #{user-info shivers}.
  720.   ((disclose ui)
  721.    (list "user-info" (user-info:name ui))))
  722.  
  723. (define-foreign %uid->user-info (user_info_uid (uid_t uid))
  724.   bool        ; win?
  725.   static-string    ; name
  726.   gid_t        ; gid
  727.   static-string    ; home-dir
  728.   static-string); shell
  729.  
  730. (define-foreign %name->user-info (user_info_name (string name))
  731.   bool        ; win?
  732.   uid_t        ; uid
  733.   gid_t        ; gid
  734.   static-string    ; home-dir
  735.   static-string); shell
  736.  
  737. (define (uid->user-info uid)
  738.   (receive (win? name gid home-dir shell)
  739.        (%uid->user-info uid)
  740.     (if win? (make-user-info name uid gid home-dir shell)
  741.     (error "Cannot get user's information" uid->user-info uid))))
  742.  
  743. (define (name->user-info name)
  744.   (receive (win? uid gid home-dir shell)
  745.        (%name->user-info name)
  746.     (if win? (make-user-info name uid gid home-dir shell)
  747.     (error "Cannot get user's information" name->user-info name))))
  748.  
  749. (define (user-info uid/name)
  750.   ((cond ((string?  uid/name) name->user-info)
  751.      ((integer? uid/name) uid->user-info)
  752.      (else (error "user-info arg must be string or integer" uid/name)))
  753.    uid/name))
  754.  
  755. ;;; Derived functions
  756.  
  757. (define (->uid uid/name)
  758.   (user-info:uid (user-info uid/name)))
  759.  
  760. (define (->username uid/name)
  761.   (user-info:name (user-info uid/name)))
  762.  
  763. (define (%homedir uid/name)
  764.   (user-info:home-dir (user-info uid/name)))
  765.  
  766.  
  767. ;;; Group info
  768. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  769.  
  770. (define-record group-info
  771.   name gid members
  772.  
  773.   ;; Make group-info records print like #{group-info wheel}.
  774.   ((disclose gi) (list "group-info" (group-info:name gi))))
  775.  
  776. ;;; These guys return static structs, so they aren't reentrant.
  777. ;;; Must be fixed for threaded version.
  778.  
  779. (define-foreign %gid->group-info
  780.   (group_info_gid (integer gid))
  781.   bool        ; win?
  782.   static-string    ; name
  783.   (C char**)    ; members
  784.   integer)    ; num members
  785.  
  786. (define-foreign %name->group-info
  787.   (group_info_name (string name))
  788.   bool        ; win?
  789.   integer    ; gid
  790.   (C char**)    ; members
  791.   integer)    ; num members
  792.  
  793. (define (gid->group-info  gid)
  794.   (receive (win? name members nmembers)
  795.        (%gid->group-info gid)
  796.     (if win?
  797.     (make-group-info name gid
  798.              (vector->list (C-string-vec->Scheme members nmembers)))
  799.     (error "Cannot get group's information for gid" gid))))
  800.                             
  801. (define (name->group-info name)
  802.   (receive (win? gid members nmembers)
  803.        (%name->group-info name)
  804.     (if win?
  805.     (make-group-info name gid
  806.              (vector->list (C-string-vec->Scheme members nmembers)))
  807.     (error "Cannot get group's information for name" name))))
  808.  
  809. (define (group-info gid/name)
  810.   ((cond ((string?  gid/name) name->group-info)
  811.      ((integer? gid/name) gid->group-info)
  812.      (else (error "group-info arg must be string or integer" gid/name)))
  813.    gid/name))
  814.  
  815. ;;; Derived functions
  816.  
  817. (define (->gid name)
  818.   (group-info:gid (group-info name)))
  819.  
  820. (define (->groupname gid)
  821.   (group-info:name (group-info gid)))
  822.  
  823. ;;; Directory stuff
  824. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  825.  
  826. (define-foreign %open-dir (open_dir (string dir-name))
  827.   (to-scheme integer "False_on_zero")    ; Win: #f, lose: errno
  828.   (C char**)                ; Vector of strings
  829.   integer)                ; Length of strings
  830.  
  831. ;;; Takes a null-terminated C vector of strings -- filenames.
  832. ;;; Sorts them in place by the Unix filename order: ., .., dotfiles, others.
  833.  
  834. (define-foreign %sort-file-vector
  835.   (scm_sort_filevec ((C "const char** ~a") cvec)
  836.             (integer    veclen))
  837.   ignore)
  838.  
  839. (define (directory-files . args)
  840.   (receive (dir dotfiles?)
  841.            (parse-optionals args "." #f)
  842.     (check-arg string? dir directory-files)
  843.     (receive (err cvec numfiles)
  844.          (%open-dir (ensure-file-name-is-nondirectory dir))
  845.       (if err (errno-error err directory-files dir dotfiles?))
  846.       (%sort-file-vector cvec numfiles)
  847.       (let ((files (vector->list (C-string-vec->Scheme&free cvec numfiles))))
  848.     (if dotfiles? files
  849.         (filter (lambda (f) (not (char=? (string-ref f 0) #\.)))
  850.             files))))))
  851.  
  852. (define (match-files regexp . maybe-dir)
  853.   (let ((dir (optional-arg maybe-dir ".")))
  854.     (check-arg string? dir match-files)
  855.     (receive (err cvec numfiles)
  856.          (%open-dir (ensure-file-name-is-nondirectory dir))
  857.       (if err (errno-error err match-files regexp dir))
  858.       (receive (err numfiles) (%filter-C-strings! regexp cvec)
  859.     (if err (error err match-files))
  860.     (%sort-file-vector cvec numfiles)
  861.     (let ((files (C-string-vec->Scheme&free cvec numfiles)))
  862.       (vector->list files))))))
  863.  
  864.  
  865. ;;; Environment manipulation
  866. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  867.  
  868. ;;; (var . val) / "var=val" rep conversion:
  869.  
  870. (define (split-env-string var=val)
  871.   (let ((i (index var=val #\=)))
  872.     (if i (values (substring var=val 0 i)
  873.           (substring var=val (+ i 1) (string-length var=val)))
  874.     (error "No \"=\" in environment string" var=val))))
  875.  
  876. (define (env-list->alist env-list)
  877.   (map (lambda (var=val)
  878.      (call-with-values (lambda () (split-env-string var=val))
  879.                cons))
  880.        env-list))
  881.  
  882. (define (alist->env-list alist)
  883.   (map (lambda (var.val) (string-append (car var.val) "=" (cdr var.val)))
  884.        alist))
  885.  
  886. ;;; ENV->ALIST
  887.  
  888. (define-foreign %load-env (scm_envvec)
  889.   (C char**)    ; char **environ
  890.   fixnum)    ; & its length.
  891.  
  892. (define (env->list)
  893.   (receive (C-env nelts) (%load-env)
  894.     (vector->list (C-string-vec->Scheme C-env nelts))))
  895.  
  896. (define (env->alist) (env-list->alist (env->list)))
  897.  
  898. ;;; ALIST->ENV
  899.  
  900. (define-foreign %install-env/errno
  901.   (install_env (vector-desc env-vec))
  902.   (to-scheme integer errno_or_false))
  903.  
  904. (define-simple-errno-syscall (%install-env env-vec) %install-env/errno)
  905.  
  906. (define (alist->env alist)
  907.   (%install-env (alist->env-list alist)))
  908.  
  909. ;;; GETENV, PUTENV, SETENV
  910.  
  911. (define-foreign getenv (getenv (string var))
  912.   static-string)
  913.  
  914. (foreign-source
  915.  "#define errno_on_nonzero_or_false(x) ((x) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  916.  "" "")
  917.  
  918. ;(define-foreign putenv/errno
  919. ;  (put_env (string var=val))
  920. ;  desc) ; #f or errno
  921.  
  922.  
  923. ;;; putenv takes a constant: const char *, cig can't figure that out..
  924. (define-foreign putenv/errno
  925.   (putenv (string-copy var=val))  no-declare
  926.   (to-scheme integer errno_on_nonzero_or_false)) ; #f or errno
  927.  
  928. (define-foreign delete-env (delete_env (string var))
  929.   ignore)
  930.  
  931. (define (putenv var=val)
  932.   (if (putenv/errno var=val)
  933.       (error "malloc failure in putenv" var=val)))
  934.  
  935. (define (setenv var val)
  936.   (if val
  937.       (putenv (string-append var "=" val))
  938.       (delete-env var)))
  939.  
  940.  
  941. ;;; Fd-ports
  942. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  943.  
  944. (define-foreign close-fdport*/errno (close_fdport (desc data))
  945.   (to-scheme integer "False_on_zero"))     ; Win: #f, lose: errno
  946.  
  947. (define (close-fdport* data) 
  948.   (let lp ()
  949.     (let ((errno (close-fdport*/errno data)))
  950.       (cond ((not errno)       #t)    ; Successful close.
  951.         ((= errno errno/badf) #f)    ; File descriptor already closed.
  952.         ((= errno errno/intr) (lp))    ; Retry.
  953.         (else
  954.          (errno-error errno close-fdport* data))))))    ; You lose.
  955.  
  956.  
  957.  
  958. (define-foreign %fdport*-read-char/errno (fdport_getchar (desc data))
  959.   desc) ; char, errno, or #f for end-of-file.
  960.  
  961. (define (%fdport*-read-char data)
  962.   (let ((c (%fdport*-read-char/errno data)))
  963.     (if (integer? c) (errno-error c %fdport*-read-char data)
  964.     (or c eof-object))))
  965.  
  966.  
  967. (define-foreign %fdport*-char-ready?/errno
  968.   (fdport_char_readyp (desc data))
  969.   desc)
  970.  
  971. (define (%fdport*-char-ready? data)
  972.   (let ((val (%fdport*-char-ready?/errno data)))
  973.     (if (integer? val) (errno-error val %fdport*-char-ready? data)
  974.     val)))
  975.  
  976. (define-foreign %fdport*-write-char/errno
  977.   (fdport_putchar (desc data) (char c))
  978.   (to-scheme integer "False_on_zero"))     ; Win: #f, lose: errno
  979.  
  980. (define-simple-errno-syscall (%fdport*-write-char desc c)
  981.   %fdport*-write-char/errno)
  982.  
  983.  
  984. (define-foreign flush-fdport*/errno (flush_fdport (desc data))
  985.   (to-scheme integer "False_on_zero"))     ; Win: #f, lose: errno
  986.  
  987. (define-simple-errno-syscall (flush-fdport* data) flush-fdport*/errno)
  988.  
  989. (define-foreign flush-all-ports/errno (flush_all_ports)
  990.   (to-scheme integer errno_or_false))
  991.  
  992. (define-simple-errno-syscall (flush-all-ports)
  993.   flush-all-ports/errno)
  994.  
  995. (define-foreign %fdport*-seek/errno
  996.   (seek_fdport (desc data) (off_t offset) (integer whence))
  997.   (to-scheme integer "False_on_zero")    ; errno
  998.   integer)                ; new position
  999.  
  1000. (define-foreign %fdport*-tell/errno
  1001.   (tell_fdport (desc data))
  1002.   (to-scheme integer "False_on_zero")    ; errno
  1003.   integer)
  1004.  
  1005. (define-foreign %fdport*-set-buffering/errno
  1006.   (set_fdbuf (desc data) (integer policy) (integer size))
  1007.   (to-scheme integer "False_on_zero"))    ; errno
  1008.  
  1009. (define-foreign %init-fdports! (init_fdports) ignore)
  1010.  
  1011. (define-foreign cloexec-unrevealed-ports (cloexec_unrevealed) ignore)
  1012.  
  1013. (define-foreign %install-port/errno
  1014.   (install_port (integer fd) (desc port))
  1015.   (to-scheme integer "False_on_zero")) ; Win: #f, lose: errno
  1016.   
  1017. (define-simple-errno-syscall (%install-port fd port) %install-port/errno)
  1018.  
  1019.  
  1020. (define-foreign %maybe-fdes->port (maybe_fdes2port (integer fd))
  1021.   desc) ; fd or #f
  1022.  
  1023.  
  1024. ;;; Doesn't signal on error. Clients must check return value.
  1025.  
  1026. (define-foreign %move-fdport
  1027.   (move_fdport (integer fd) (desc port) (integer new-revealed-count))
  1028.   bool) ; Win: #f, lose: #t
  1029.  
  1030.  
  1031. (define-foreign read-fdport*-substring!/errno
  1032.   (read_fdport_substring (string-desc buf)
  1033.              (integer start)
  1034.              (integer end)
  1035.              (desc data))
  1036.   (multi-rep (to-scheme integer errno_or_false)
  1037.          integer))
  1038.  
  1039. (define-foreign write-fdport*-substring/errno
  1040.   (write_fdport_substring (string-desc buf)
  1041.               (integer start)
  1042.               (integer end)
  1043.               (desc fdport))
  1044.   (multi-rep (to-scheme integer errno_or_false)
  1045.          integer))
  1046.  
  1047.  
  1048. ;;; Some of fcntl()
  1049. ;;;;;;;;;;;;;;;;;;;
  1050.  
  1051. (define-foreign %fcntl-read/errno (fcntl_read (fixnum fd) (fixnum command))
  1052.   (multi-rep (to-scheme integer errno_or_false)
  1053.          integer))
  1054.  
  1055. (define-foreign %fcntl-write/errno
  1056.   (fcntl_write (fixnum fd) (fixnum command) (fixnum val))
  1057.   (to-scheme integer errno_or_false))
  1058.  
  1059. (define-errno-syscall (%fcntl-read fd command) %fcntl-read/errno value)
  1060. (define-simple-errno-syscall (%fcntl-write fd command val) %fcntl-write/errno)
  1061.  
  1062. (define (i/o-flags fd/port)
  1063.   (call/fdes fd/port
  1064.     (lambda (fd) (%fcntl-read fd fcntl/get-file-flags))))
  1065.  
  1066.  
  1067. ;;; Miscellaneous
  1068. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1069.  
  1070. ;;; usleep(3): Try to sleep for USECS microseconds.
  1071. ;;; sleep(3):  Try to sleep for SECS seconds.
  1072.  
  1073. ; De-released -- not POSIX and not on SGI systems.
  1074. ; (define-foreign usleep (usleep (integer usecs)) integer)
  1075.  
  1076. (define-foreign sleep (sleep (uint_t secs)) uint_t)
  1077.  
  1078. (define-foreign %gethostname (scm_gethostname)
  1079.   static-string)
  1080.  
  1081. (define system-name %gethostname)
  1082.  
  1083. (define-foreign errno-msg (errno_msg (integer i))
  1084.   static-string)
  1085.